Tidy tuesday - Unemployment EDA

1 Options & libs

# Turning scientific / Exponential numbers off

options(scipen = 999)

library(tidyverse)
library(tidytuesdayR)
library(ggthemes)
library(glue)
library(scales)

view missing data

library(naniar)

Creating & setting custom theme

theme_viny_bright <- function(){
  
  library(ggthemes)
  
  ggthemes::theme_fivethirtyeight() %+replace%
  
  theme(
    axis.title = element_text(size = 9),
    axis.text = element_text(size = 8),
    legend.text = element_text(size = 7),
    panel.background = element_rect(fill = "white"),
    plot.background = element_rect(fill = "white"),
    strip.background = element_blank(),
    legend.background = element_rect(fill = NA),
    legend.key = element_rect(fill = NA),
    plot.title = element_text(hjust = 0.5,
                              size = 16,
                              face = "bold"),
    plot.subtitle = element_text(hjust = 0.5, size = 10, face = "bold"),
    plot.caption = element_text(hjust = 1, size = 8)
      )
  
  }

theme_set(theme_viny_bright())

sources:

Inspired from: https://www.youtube.com/watch?v=EHqFDXa-sH4&t=2105s

2 Loading data

tt <- tt_load("2021-03-02")
tt

3 EDA

youtube <- tt$youtube
youtube

str(youtube)

summary(youtube)

youtube %>% 
  mutate_if(is.character, as.factor) %>% 
  summary()

missing value

naniar::gg_miss_upset(data = youtube)

youtube %>% 
  count(brand) %>% 
  
  mutate(brand = fct_reorder(brand, n)) %>% 
  
  ggplot(aes(x = n, y = brand)) +
  geom_col()

youtube %>% 
  
  ggplot(aes(x = year, fill = brand)) +
  geom_bar() +
  facet_wrap(~brand) +
  guides(x = guide_axis(n.dodge = 2))

youtube %>% 
  na.omit() %>% 
  mutate(brand = fct_reorder(brand, view_count)) %>% 
  
  ggplot(aes(x = view_count, y = brand)) +
  geom_boxplot() +
  # geom_jitter(alpha = 0.3) +
  scale_x_log10(labels = comma)

youtube %>% 
  na.omit() %>%
  mutate(brand = fct_reorder(brand, view_count)) %>% 
   
  ggplot(aes(x = view_count, y = brand)) +
  geom_violin(draw_quantiles = c(0.25, 0.5, 0.75)) +
  geom_jitter(alpha = 0.3) +
  scale_x_log10(labels = comma)

youtube %>% 
  na.omit() %>% 
  mutate(brand = fct_reorder(brand, view_count)) %>% 
  
  ggplot(aes(x = view_count, y = brand, fill = funny)) +
  geom_boxplot() +
  # geom_jitter(alpha = 0.3) +
  scale_x_log10(labels = comma)

youtube %>% 
  na.omit() %>% 
  mutate(brand = fct_reorder(brand, view_count)) %>% 
  
  ggplot(aes(x = view_count, y = brand, fill = use_sex)) +
  geom_boxplot() +
  # geom_jitter(alpha = 0.3) +
  scale_x_log10(labels = comma)

youtube %>% colnames()

youtube %>% 
  pivot_longer(names_to = "ads_category", values_to = "true_false", 
               cols = funny:use_sex)

3.0.1 popular categories in brands

youtube %>% 
  pivot_longer(names_to = "ads_category", values_to = "true_false", 
               cols = funny:use_sex) %>% 
  filter(true_false == "TRUE") %>% 
  
  ggplot(aes(y = ads_category, x = view_count)) +
  geom_col() +
  facet_wrap(~brand)

library(tidytext)

3.0.1.1 log of view_count

youtube %>% 
  pivot_longer(names_to = "ads_category", values_to = "true_false", 
               cols = funny:use_sex) %>% 
  filter(true_false == "TRUE") %>% 
  
  ggplot(aes(y = fct_reorder(ads_category, view_count), 
             x = view_count)) +
  geom_col() +
  facet_wrap(~brand) +
  scale_x_log10()

3.0.1.2 reorder_within by view_count

youtube %>%
  na.omit() %>% 
  pivot_longer(names_to = "ads_category", values_to = "true_false", 
               cols = funny:use_sex) %>% 
  filter(true_false == "TRUE",
         view_count > 10000) %>% 
  group_by(brand, ads_category, view_count) %>% 
  summarise(view_count = sum(view_count)) %>% 
  ungroup() %>% 
  mutate_if(is.character, factor) %>% 
  mutate(ads_category = reorder_within(x = ads_category, by = view_count, within = brand)) %>% 
  
  ggplot(aes(y = ads_category, x = view_count)) +
  geom_col() +
  facet_wrap(~brand, scales = "free_y") +
  scale_y_reordered() +
  theme(axis.text.x = element_text(angle = 90)) +
  scale_x_continuous(labels = unit_format(unit = "M", scale = 1e-6))

gathered_categories <- youtube %>% 
  na.omit() %>% 
  gather(ads_category, true_false, funny:use_sex)

gathered_categories

3.0.1.3 view_count by pct

gathered_categories %>% 
  filter(true_false == "TRUE",
         ) %>% # view_count > 10000
  
  group_by(brand, ads_category) %>% 
  summarise(view_count = sum(view_count)) %>% 
  
  group_by(brand) %>% 
  mutate(pct = view_count / sum(view_count)) %>% 
  
  # mutate_if(is.character, factor) %>% 
  mutate(ads_category = reorder_within(x = ads_category, by = pct, within = brand)) %>% 
  
  ggplot(aes(y = ads_category, x = view_count)) +
  geom_col() +
  facet_wrap(~brand, scales = "free_y") +
  scale_y_reordered() +
  
  theme(axis.text.x = element_text(angle = 90)) +
  scale_x_continuous(labels = unit_format(unit = "M", scale = 1e-6))

3.0.1.4 by pct

wrapping axis text using str_wrap() from: https://stackoverflow.com/questions/21878974/wrap-long-axis-labels-via-labeller-label-wrap-in-ggplot2

gathered_categories %>% 
  filter(true_false == "TRUE",
         ) %>% # view_count > 10000
  
  group_by(brand, ads_category) %>% 
  summarise(view_count = sum(view_count)) %>% 
  
  group_by(brand) %>% 
  mutate(pct = view_count / sum(view_count),
         ads_category = str_replace_all(ads_category,"_"," "),
         ads_category = str_wrap(ads_category, width = 10)) %>% 
  
  # mutate_if(is.character, factor) %>% 
  mutate(ads_category = reorder_within(x = ads_category, by = pct, within = brand)
         ) %>%
  
  ggplot(aes(y = ads_category, x = pct)) +
  geom_col() +
  facet_wrap(~brand, scales = "free_y") +
  scale_y_reordered() +
  
  theme(axis.text.x = element_text(angle = 90)) +
  scale_x_continuous(labels = percent)

3.0.1.5 pct+view_count labels

Adding view_count to axis text in above chart

gathered_categories %>% 
  filter(true_false == "TRUE",
         ) %>% # view_count > 10000
  
  group_by(brand, ads_category) %>% 
  summarise(view_count = sum(view_count)) %>% 
  
  group_by(brand) %>% 
  mutate(pct = view_count / sum(view_count),
         ads_category = str_replace_all(ads_category,"_"," "),
         ads_category = paste(ads_category,view_count),
         ads_category = str_wrap(ads_category, width = 10)) %>% 
  
  # mutate_if(is.character, factor) %>% 
  mutate(ads_category = reorder_within(x = ads_category, by = pct, within = brand)
         ) %>%
  
  ggplot(aes(y = ads_category, x = pct)) +
  geom_col() +
  facet_wrap(~brand, scales = "free_y") +
  scale_y_reordered() +
  
  theme(axis.text.x = element_text(angle = 90)) +
  scale_x_continuous(labels = percent)

test_set = data.frame(x = c("label", "long label", "very,_very_long_label"), 
                y = c(10, 15, 20))

test_set$newx = str_wrap(test_set$x, width = 10)

ggplot(test_set, aes(newx, y)) + 
  xlab("") + ylab("Number of Participants") +
  geom_bar(stat = "identity")

youtube %>% 
  na.omit() %>% 
  gather(key = category, value = value, funny:use_sex) %>% 
  
  group_by(category,
           year = 2 * (year %/% 2)) %>% 
  summarise(pct = mean(value), n = n()) %>% 
  
  ggplot(aes(x = year, y = pct, col = category)) +
  geom_path(size = .9) +
  scale_y_continuous(labels = percent) +
  facet_wrap(~category) +
  theme(legend.position = "none")

youtube %>% 
  na.omit() %>% 
  gather(key = category, value = value, funny:use_sex) %>% 
  
  group_by(category = str_to_title(str_replace_all(category, "_", " ")),
           year = 2 * (year %/% 2)) %>% 
  summarise(pct = mean(value), 
            n = n()) %>% 
  
  ggplot(aes(x = year, y = pct, col = category)) +
  geom_path(size = .9) +
  scale_y_continuous(labels = percent) +
  facet_wrap(~category) +
  theme(legend.position = "none")

3.1 Testing Statistically

checking trend statistically related to year or not

glm(animals ~ year, family = "binomial", data = youtube) %>% 
  summary()

Statistically above relation doesn’t exist

glm(celebrity ~ year, family = "binomial", data = youtube) %>% 
  summary()

statistically year has relationship with celebrity

3.1.1 broom loops

Running loop on all using broom

youtube %>% 
  gather(category, value, funny:use_sex) %>% 
  group_by(category) %>% 
  nest()

youtube %>% 
  gather(category, value, funny:use_sex) %>% 
  group_by(category) %>% 
  summarise(model = list(glm(value ~ year, family = "binomial") )) %>% 
  mutate(td_modeldata = map(model, broom::tidy))

coefficients <-  youtube %>% 
  # na.omit() %>% 
  gather(category, value, funny:use_sex) %>% 
  group_by(category) %>% 
  summarise(model = list(glm(value ~ year, family = "binomial") )) %>% 
  mutate(td_modeldata = map(model, broom::tidy)) %>% 
  unnest(td_modeldata) %>% 
  filter(term != "(Intercept)") %>% 
  arrange(desc(estimate))

coefficients

Categories with Only significant relationship with year

youtube %>% 
  na.omit() %>% 
  gather(key = category, value = value, funny:use_sex) %>% 
  
  group_by(category,
           year = 2 * (year %/% 2)) %>% 
  summarise(pct = mean(value), 
            n = n()) %>% 
  
  inner_join(coefficients, by = "category") %>% 
  mutate(category = str_to_title(str_replace_all(category, "_", " "))) %>% 
  filter(p.value <= .01) %>% 
  
  ggplot(aes(x = year, y = pct, col = category)) +
  geom_path(size = .9) +
  scale_y_continuous(labels = percent) +
  facet_wrap(~category) +
  theme(legend.position = "none")